home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / ilisp / cmulisp.lisp.z / cmulisp.lisp
Encoding:
Text File  |  1998-05-21  |  8.9 KB  |  270 lines
  1. ;;; -*- Mode: Lisp -*-
  2.  
  3. ;;; cmulisp.lisp --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.8
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
  11. ;;;               1996 Marco Antoniotti and Rick Campbell
  12. ;;;
  13. ;;; Other authors' names for which this Copyright notice also holds
  14. ;;; may appear later in this file.
  15. ;;;
  16. ;;; Send mail to 'ilisp-request@naggum.no' to be included in the
  17. ;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP
  18. ;;; mailing list were bugs and improvements are discussed.
  19. ;;;
  20. ;;; ILISP is freely redistributable under the terms found in the file
  21. ;;; COPYING.
  22.  
  23.  
  24.  
  25. ;;;
  26. ;;; Todd Kaufmann    May 1990
  27. ;;;
  28. ;;; Make CMU CL run better within GNU inferior-lisp (by ccm).
  29. ;;;
  30.  
  31.  
  32. (in-package "ILISP")
  33.  
  34. ;;;% CMU CL does not define defun as a macro
  35. (defun ilisp-compile (form package filename)
  36.   "Compile FORM in PACKAGE recording FILENAME as the source file."
  37.   (ilisp-errors
  38.    (ilisp-eval
  39.     (format nil "(funcall (compile nil '(lambda () ~A)))" form)
  40.     package filename)))
  41.  
  42. ;;;% Stream settings, when running connected to pipes.
  43. ;;;
  44. ;;; This fixes a problem when running piped: When CMU is running as a piped
  45. ;;; process, *terminal-io* really is a terminal; ie, /dev/tty.  This means an
  46. ;;; error will cause lisp to stop and wait for input from /dev/tty, which it
  47. ;;; won't be able to grab, and you'll have to restart your lisp.  But we want
  48. ;;; it to use the same input that the user is typing in, ie, the pipe (stdin).
  49. ;;; This fixes that problem, which only occurs in the CMU cores of this year.
  50. ;;;
  51.  
  52. (defvar *Fix-pipe-streams* T
  53.   "Set to Nil if you want them left alone.  And tell me you don't get stuck.")
  54.  
  55. (when (and *Fix-pipe-streams*
  56.        (lisp::synonym-stream-p *terminal-io*)
  57.        (eq (lisp::synonym-stream-symbol *terminal-io*)
  58.            'SYSTEM::*TTY*))
  59.   (setf *terminal-io* (make-two-way-stream system::*stdin* system::*stdout*))
  60.   ;; *query-io* and *debug-io* are synonym streams to this, so this fixes
  61.   ;; everything.
  62.   )
  63.  
  64. ;;;% Debugger extensions
  65.  
  66. ;;;%% Implementation of a :pop command for CMU CL debugger
  67.  
  68. ;;;
  69. ;;; Normally, errors which occur while in the debugger are just ignored, unless
  70. ;;; the user issues the "flush" command, which toggles this behavior.
  71. ;;;
  72. (setq debug:*flush-debug-errors* nil)  ;; allow multiple error levels.
  73.  
  74. ;;; This implementation of "POP" simply looks for the first restart that says
  75. ;;; "Return to debug level n" or "Return to top level." and executes it.
  76. ;;;
  77. (debug::def-debug-command "POP" #+:new-compiler ()
  78.     ;; find the first "Return to ..." restart
  79.     (if (not (boundp 'debug::*debug-restarts*))
  80.     (error "You're not in the debugger; how can you call this!?")
  81.     (labels ((find-return-to (restart-list num)
  82.          (let ((first
  83.             (member-if
  84.              #'(lambda (restart)
  85.                  (string= (funcall
  86.                        (conditions::restart-report-function restart)
  87.                        nil)
  88.                       "Return to " :end1 10))
  89.               restart-list)))
  90.            (cond ((zerop num) (car first))
  91.              ((cdr first) (find-return-to (cdr first) (1- num)))))))
  92.     (let* ((level (debug::read-if-available 1))
  93.            (first-return-to (find-return-to 
  94.                  debug::*debug-restarts* (1- level))))
  95.       (if (null first-return-to)
  96.           (format *debug-io* "pop: ~d is too far" level)
  97.           (debug::invoke-restart-interactively first-return-to)
  98.           ))))
  99.     )
  100.  
  101.  
  102. ;;;%% arglist/source-file utils.
  103.  
  104. (defun get-correct-fn-object (sym)
  105.   "Deduce how to get the \"right\" function object and return it."
  106.   (let ((fun (or (macro-function sym)
  107.          (and (fboundp sym) (symbol-function sym)))))
  108.     (cond (fun
  109.        (when (and (= (lisp::get-type fun) #.vm:closure-header-type)
  110.               (not (eval:interpreted-function-p fun)))
  111.          (setq fun (lisp::%closure-function fun)))
  112.        fun)
  113.       (t
  114.        (error "Unknown function ~a.  Check package." sym)
  115.        nil))))
  116.  
  117.  
  118.  
  119. (export '(arglist source-file cmulisp-trace))
  120.  
  121. ;;;%% arglist - return arglist of function
  122.  
  123. (defun arglist (symbol package)
  124.   (ilisp-errors
  125.    (let* ((x (ilisp-find-symbol symbol package))
  126.       (fun (get-correct-fn-object x)))
  127.      (values
  128.       (cond ((eval:interpreted-function-p fun) 
  129.          (eval:interpreted-function-arglist fun))
  130.         ((= (lisp::get-type fun)
  131.         #.vm:funcallable-instance-header-type) 
  132.          ;; generic function / method
  133.          (pcl::generic-function-pretty-arglist fun))
  134.         ((compiled-function-p fun)
  135.          (let ((string-or-nil
  136.             (#+CMU17 lisp::%function-arglist
  137.              #-CMU17 lisp::%function-header-arglist
  138.              fun)))
  139.            (if string-or-nil
  140.            (read-from-string string-or-nil)
  141.            "No argument info.")))
  142.         (t (error "Unknown type of function")))))))
  143.  
  144.  
  145. ;;; source-file symbol package type --
  146. ;;; New version provided by Richard Harris <rharris@chestnut.com> with
  147. ;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>.
  148.  
  149. (defun source-file (symbol package type)
  150.   (declare (ignore type))
  151.   (ilisp-errors
  152.    (let* ((x (ilisp-find-symbol symbol package))
  153.       (fun (get-correct-fn-object x)))
  154.      (when (and fun (not (eval:interpreted-function-p fun)))
  155.        ;; The hack above is necessary because CMUCL does not
  156.        ;; correctly record source file information when 'loading'
  157.        ;; a non compiled file.
  158.        ;; In this case we fall back on the TAGS machinery.
  159.        ;; (At least as I underestand the code).
  160.        ;; Marco Antoniotti 11/22/94.
  161.        (cond (#+CMU17 (pcl::generic-function-p fun)
  162.               #-CMU17
  163.               (= (lisp::get-type fun)
  164.                  #.vm:funcallable-instance-header-type)
  165.               (dolist (method (pcl::generic-function-methods fun))
  166.                   (print-simple-source-info
  167.                    (or #+CMU17
  168.                        (pcl::method-fast-function method)
  169.                        (pcl::method-function method))))
  170.               t)
  171.          (t (print-simple-source-info fun)))))))
  172.  
  173. ;;; Old version. Left here for the time being.
  174. ;(defun source-file (symbol package type)
  175. ;  (declare (ignore type))
  176. ;  (ilisp-errors
  177. ;   (let* ((x (ilisp-find-symbol symbol package))
  178. ;      (fun (get-correct-fn-object x)))
  179. ;     (when fun
  180. ;       (cond ((= (lisp::get-type fun)
  181. ;         #.vm:funcallable-instance-header-type)
  182. ;          ;; A PCL method! Uh boy!
  183. ;          (dolist (method (pcl::generic-function-methods fun))
  184. ;        (print-simple-source-info
  185. ;         (lisp::%closure-function (pcl::method-function method))))
  186. ;          t)
  187. ;         (t (print-simple-source-info fun)))))))
  188.  
  189.  
  190. ;;; Patch suggested by Richard Harris <rharris@chestnut.com>
  191.  
  192. ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
  193. ;;; returns a pathname for the file the function was defined in.  If it was
  194. ;;; not defined in some file, then nil is returned.
  195. ;;;
  196. ;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f), 
  197. ;;; with added read-time conditionalization to work in older versions
  198. ;;; of cmucl.  It may need a little bit more conditionalization for
  199. ;;; some older versions of cmucl.
  200.  
  201. (defun fun-defined-from-pathname (function)
  202.   "Returns the file where FUNCTION is defined in (if the file can be found).
  203. Takes a symbol or function and returns the pathname for the file the
  204. function was defined in.  If it was not defined in some file, nil is
  205. returned."
  206.   (flet ((frob (code)
  207.            (let ((info #+CMU17 (kernel:%code-debug-info code)
  208.                #-CMU17 (kernel:code-debug-info code)))
  209.          (when info
  210.                (let ((sources (c::debug-info-source info)))
  211.              (when sources
  212.                    (let ((source (car sources)))
  213.                  (when (eq (c::debug-source-from source) :file)
  214.                        (c::debug-source-name source)))))))))
  215.     (typecase function
  216.           (symbol (fun-defined-from-pathname (fdefinition function)))
  217.           #+CMU17
  218.           (kernel:byte-closure
  219.            (fun-defined-from-pathname
  220.             (kernel:byte-closure-function function)))
  221.           #+CMU17
  222.           (kernel:byte-function
  223.            (frob (c::byte-function-component function)))
  224.           (function
  225.            (frob (kernel:function-code-header
  226.               (kernel:%function-self function))))
  227.           (t nil))))
  228.  
  229.  
  230. ;;; print-simple-source-info --
  231. ;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and
  232. ;;; Richard Harris <rharris@chestnut.com>
  233. ;;; Nov 21, 1994.
  234.  
  235. (defun print-simple-source-info (fun)
  236.   (let ((path (fun-defined-from-pathname fun)))
  237.     (when (and path (probe-file path))
  238.       (print (namestring (truename path)))
  239.       t)))
  240.  
  241.  
  242. ;;; Old version (semi patched). Left here for the time being.
  243. ;(defun print-simple-source-info (fun)
  244. ;  (let ((info (#+CMU17
  245. ;           kernel:%code-debug-info
  246. ;           #-CMU17
  247. ;           kernel:code-debug-info       
  248. ;           (kernel:function-code-header fun))))
  249. ;    (when info
  250. ;      (let ((sources (c::compiled-debug-info-source info)))
  251. ;        (when sources
  252. ;          (dolist (source sources)
  253. ;              (let ((name (c::debug-source-name source)))
  254. ;                (when (eq (c::debug-source-from source) :file)
  255. ;                  ;; Patch suggested by
  256. ;                  ;; hunter@work.nlm.nih.gov (Larry
  257. ;                  ;; Hunter) 
  258. ;                  ;; (print (namestring name)) ; old
  259. ;                  (print (truename name))
  260. ;                  )))
  261. ;          t)))))
  262.  
  263.  
  264. (defun cmulisp-trace (symbol package breakp)
  265.   "Trace SYMBOL in PACKAGE."
  266.   (ilisp-errors
  267.    (let ((real-symbol (ilisp-find-symbol symbol package)))
  268.      (setq breakp (read-from-string breakp))
  269.      (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
  270.